Language/OS - Multiplatform Resource Library/LANGUAGE OS.iso/lisp/eulisp/mpfeel.lha/MPFeel/Modules/initcode.em

Lisp/Scheme | 1992-10-06 | 17KB | 545 lines

;; Eulisp Module
;; Author: pab
;; File: initcode.em
;; Date: Mon Dec  9 22:36:26 1991
;;
;; Project:
;; Description:
;;

(defmodule initcode
  (threads arith calls symbols strings characters list-operators
   streams vectors lists ccc tables classes (rename ((null Null)) class-names) errors
   generics others module-operators formatted-io bit-vectors
   root semaphores sockets)
  ()

  ;; install the callbacks


  ;; define add-method

  (defun simple-add-method (gf meth)
    ((lambda (sig table)
       (if (null table)
       (generic-method-table-setter gf (mk-initial-table sig (list meth)))
     (add-meth-aux table sig (list meth)))
       ;;(if (methodp (car (find-applicable-methods gf sig)))
       ;;nil
       ;;(cerror  (find-applicable-methods gf sig) nil))
       ;; invalidate cache
       (generic-fast-method-cache-setter gf nil)
       (generic-slow-method-cache-setter gf nil)
       gf)
     (method-signature meth)
     (generic-method-table gf)))

  (defun add-method-method (h1 h2 gf meth)
    (simple-add-method gf meth))

  (defun mk-initial-table (initkey initentry)
    (fold (lambda (class tab)
        (cons (cons class tab) nil))
      (reverse initkey)
      initentry))

  ;; starting this lot up...

  (defun add-meth-aux (table sig meth)
    ((lambda (xx)
       (if (null table)
       ;; should never happen
       (swizzle)
     (if (null xx)
         (progn (nconc table
               (fold (lambda (class tab)
                   (cons (cons class tab) nil))
                 (reverse sig)
                 meth))
            table)
       (if (null (cdr sig))
           ;; must have a relacement method
           ((setter cdr) xx meth)
         (add-meth-aux (cdr xx) (cdr sig) meth)))))
     (my-assq (car sig) table)))

  (defun add-method-to-slow-cache (gf sig meths)
    ((lambda (table)
       (if (null table)
       (generic-slow-method-cache-setter
        gf
        (mk-initial-table sig (cons sig meths)))
     (add-meth-aux table sig (cons sig meths)))
       table)
     (generic-slow-method-cache gf)))

  (defun find-applicable-methods (gf sig)
    (find-applic-methods-aux (generic-method-table gf)
                 (mapcar class-precedence-list sig)))

  (export find-applicable-methods)
  ;; wasteful...
  (defun find-applic-methods-aux (table cpl-lst)
    (if (null cpl-lst)
    nil
      (if (null (car cpl-lst))
      nil
    ((lambda (xx)
       (if (null xx)
           (find-applic-methods-aux table
                    (cons (cdr (car cpl-lst))
                          (cdr cpl-lst)))
         (if (null (cdr cpl-lst))
         ;; found summat
         (if (methodp (car (cdr xx)))
             (cons (car (cdr xx))
                           (find-applic-methods-aux table
                                                    (cons (cdr (car cpl-lst))
                                                          (cdr cpl-lst))))
           (progn (print "error-1")
              (print (list xx cpl-lst))
              (print "error-1")
              (print (list xx cpl-lst))
              nil))
           (append (find-applic-methods-aux (cdr xx) (cdr cpl-lst))
               (find-applic-methods-aux table
                        (cons (cdr (car cpl-lst))
                              (cdr cpl-lst)))))))
     (my-assq (car (car cpl-lst)) table)))))

  (defun find-and-call-generic (gf args)
    (find-and-call-generic-1 gf args (mapcar class-of args)))

  (defun find-and-call-generic-1 (gf args sig)
    ((lambda (meths)
       (if (null meths)
       (progn (setq x (list gf sig args))
          (error "No applicable method" Internal-Error
             'error-value (list gf sig)))
     (progn (add-method-to-slow-cache gf sig meths)
        (generic-fast-method-cache-setter gf
                          (cons sig meths))
        (if (methodp (car meths))
            (call-method-by-list meths args)
          (cerror meths nil)))))
     ((generic-discriminator gf) sig)))

  ;; use this at bootstrap...
  (defun default-compute-discriminating-function (gf)
    (lambda (sig)
      (find-applicable-methods gf sig)))

  (defun compute-discriminating-function-as-method (foo bar gf)
    (lambda (sig)
      (find-applicable-methods gf sig)))

  ;; add as a method...

  ;; necessary functions

  (defun fold (fn lst val)
    (if (null lst) val
      (fold fn (cdr lst)
        (fn (car lst) val))))

  (defun reverse (x)
    (fold cons x nil))

  (defun my-mapcar (fn lst)
    (if (null lst) nil
      (cons (fn (car lst))
        (mapcar fn (cdr lst)))))

  (defun my-assq (obj lst)
    (if (null lst) nil
      (if (eq (car (car lst)) obj)
      (car lst)
    (my-assq obj (cdr lst)))))

  ;; Should have enough in place now...

  (set-compute-and-apply-fn find-and-call-generic)

  ;; very much hacked up bootstrap

  (defun init-generic (gf)
    (generic-discriminator-setter gf
                  (default-compute-discriminating-function gf)))

  ;; bung in the discriminators...
  (init-generic allocate-instance)
  (init-generic initialize-instance)
  (init-generic compute-discriminating-function)
  (init-generic add-method)
  (init-generic compute-class-precedence-list)
  (init-generic slot-value-using-class)
  (init-generic (setter slot-value-using-class))
  (init-generic slot-value-using-slot-description)
  (init-generic (setter slot-value-using-slot-description))
  (init-generic find-slot-description)
  (init-generic make-slot-description)
  (init-generic make-inherited-slot-description)
  (init-generic add-slot-description)
  (init-generic generic-write)
  (init-generic generic-prin)
  (init-generic binary-plus)
  (init-generic binary-times)
  (init-generic binary-difference)
  (init-generic binary-divide)
  (init-generic binary-gcd)
  (init-generic binary-lcm)
  (init-generic binary-lcm)
  (init-generic =)
  (init-generic zerop)
  (init-generic abs)
  (init-generic binary-lt)
  (init-generic binary-gt)
  (init-generic equal)
  (init-generic copy)

  (simple-add-method allocate-instance
          (generic_initialize_instance\,Method
           (generic_allocate_instance\,Method_Class method nil)
           (list 'signature (list method-class object)
             'function generic_allocate_instance\,Method_Class)))


  (simple-add-method initialize-instance
          (generic_initialize_instance\,Method
           (generic_allocate_instance\,Method_Class method nil)
           (list 'signature (list method object)
             'function generic_initialize_instance\,Method)))

  (simple-add-method add-method
          (generic_initialize_instance\,Method
           (generic_allocate_instance\,Method_Class method nil)
           (list 'signature (list generic-function method)
             'function add-method-method)))

  ;; should be enough
  (add-method allocate-instance
          (make-instance method
                 'signature (list class object)
                 'function
                 generic_allocate_instance\,StandardClass))

  (add-method allocate-instance
          (generic_initialize_instance\,Method
           (generic_allocate_instance\,Method_Class method nil)
           (list 'signature (list generic-class object)
             'function generic_allocate_instance\,Generic_Class)))

  (add-method initialize-instance
          (generic_initialize_instance\,Method
           (generic_allocate_instance\,Method_Class method nil)
           (list 'signature (list generic-function object)
             'function generic_initialize_instance\,Generic)))

  (add-method allocate-instance
          (make-instance method
                 'signature (list structure-class object)
                 'function
                 generic_allocate_instance\,StructureClass))

  (add-method allocate-instance
          (make-instance method
                 'signature (list slot-description-class object)
                 'function
                 generic_allocate_instance\,Slot_Description_Class))

  (add-method allocate-instance
          (make-instance method
                 'signature (list condition-class object)
                 'function
                 generic_allocate_instance\,Condition_Class))

  (add-method allocate-instance
          (make-instance method
                 'signature (list primitive-class object)
                 'function
                 generic_allocate_instance\,Primitive_Class))

  (add-method initialize-instance
          (make-instance method
                 'signature (list object object)
                 'function
                 generic_initialize_instance\,Object))

  (add-method initialize-instance
          (make-instance method
                 'signature (list class object)
                 'function
                 generic_initialize_instance\,Standard_Class))

  (add-method initialize-instance
          (make-instance method
                 'signature (list slot-description object)
                 'function
                 generic_initialize_instance\,Slot_Description))

  (add-method initialize-instance
          (make-instance method
                 'signature (list condition object)
                 'function
                 generic_initialize_instance\,Default_Condition))
  ;; More initting
  (add-method compute-class-precedence-list
          (make-instance method
                 'signature (list class)
                 'function generic_compute_class_precedence_list\,Standard_Class))


  ;; slot access

  (add-method slot-value-using-class
          (make-instance method
                 'signature (list class object object)
                 'function generic_slot_value_using_class\,Standard_Class))

  (add-method slot-value-using-class
          (make-instance method
                 'signature (list structure-class object object)
                 'function generic_slot_value_using_class\,Structure_Class))


  (add-method (setter slot-value-using-class)
          (make-instance method
                 'signature (list class object object object)
                 'function generic_slot_value_using_class_setter\,Standard_Class))

  (add-method (setter slot-value-using-class)
          (make-instance method
                 'signature (list structure-class object object object)
                 'function generic_slot_value_using_class_setter\,StructureClass))

  (add-method slot-value-using-slot-description
          (make-instance method
                 'signature (list object local-slot-description)
                 'function
                 generic_slot_value_using_slot_description\,Object\,Local_Slot_Description))

  (add-method slot-value-using-slot-description
          (make-instance method
                 'signature (list object local-slot-description)
                 'function
                 generic_slot_value_using_slot_description\,Object\,Local_Slot_Description))

  (add-method (setter slot-value-using-slot-description)
          (make-instance method
                 'signature (list object local-slot-description object)
                 'function ;; should have been called fred.
                 generic_slot_value_using_slot_description_setter\,Object\,Local_Slot_Description))

  (add-method find-slot-description
          (make-instance method
                 'signature (list structure-class object)
                 'function generic_find_slot_description\,Structure_Class))

  (add-method find-slot-description
          (make-instance method
                 'signature (list class object)
                 'function generic_find_slot_description\,Standard_Class))

  (add-method make-slot-description
          (make-instance method
                 'signature (list class object)
                 'function generic_make_slot_description\,Standard_Class))

  (add-method make-inherited-slot-description
          (make-instance method
                 'signature (list class slot-description object)
                 'function
                 generic_make_inherited_slot_description\,Standard_Class\,Slot_Description))

  (add-method add-slot-description
          (make-instance method
                 'signature (list class slot-description)
                 'function generic_add_slot_description\,StandardClass\,SlotDescription))


  (add-method add-slot-description
          (make-instance method
                 'signature (list class local-slot-description)
                 'function
                 generic_add_slot_description\,StandardClass\,LocalSlotDescription))



  ;; streams

  (add-method generic-write
          (make-instance method
                 'signature (list object object)
                 'function generic_generic_write\,Object))
  (add-method generic-prin
          (make-instance method
                 'signature (list object object)
                 'function generic_generic_prin\,Object))

  (add-method generic-prin
          (make-instance method
                 'signature (list pair object)
                 'function generic_generic_prin\,Cons))

  ;; arithmetic...


  (add-method binary-plus
          (make-instance method
                 'signature (list number number)
                 'function generic_binary_plus\,Number\,Number))

  (add-method binary-plus
          (make-instance method
                 'signature (list integer integer)
                 'function generic_binary_plus\,Integer\,Integer))

  (add-method binary-difference
          (make-instance method
                 'signature (list number number)
                 'function generic_binary_difference\,Number\,Number))

  (add-method binary-difference
          (make-instance method
                 'signature (list integer integer)
                 'function generic_binary_difference\,Integer\,Integer))

  (add-method binary-times
          (make-instance method
                 'signature (list number number)
                 'function generic_binary_times\,Number\,Number))

  (add-method binary-times
          (make-instance method
                 'signature (list integer integer)
                 'function generic_binary_times\,Integer\,Integer))

  (add-method binary-divide
          (make-instance method
                 'signature (list number number)
                 'function generic_binary_divide\,Number\,Number))


  (add-method binary-gcd
          (make-instance method
                 'signature (list integer integer)
                 'function generic_binary_gcd\,Integer\,Integer))


  (add-method binary-lcm
          (make-instance method
                 'signature (list integer integer)
                 'function generic_binary_lcm\,Integer\,Integer))


  (add-method =
          (make-instance method
                 'signature (list number number)
                 'function generic_eqn\,Number\,Number))

  (add-method equal
          (make-instance method
                 'signature (list number number)
                 'function generic_equal\,Number\,Number))

  (add-method zerop
          (make-instance method
                 'signature (list number )
                 'function generic_zerop\,Number))

  (add-method abs
          (make-instance method
                 'signature (list number)
                 'function generic_abs\,Number))

  (add-method binary-lt
          (make-instance method
                 'signature (list number number)
                 'function generic_binary_lt\,Number\,Number))

  (add-method binary-gt
          (make-instance method
                'signature (list integer integer)
                'function generic_binary_gt\,Integer\,Integer))
  (add-method binary-lt
          (make-instance method
                 'signature (list integer integer)
                 'function generic_binary_lt\,Integer\,Integer))

  (add-method binary-gt
          (make-instance method
                'signature (list number number)
                'function generic_binary_gt\,Number\,Number))

  ;; threads
  ;; Note that these 2 only exist in BSD+SYSV versions...
  (if (eq (feel-machine-type) 'generic)
      ()
    (progn (add-method allocate-instance
               (make-instance method
                      'signature (list thread-class object)
                      'function generic_allocate_instance\,Thread_Class))


       (add-method initialize-instance
               (make-instance method
                      'signature (list thread object)
                      'function generic_initialize_instance\,Thread_Class))


       (add-method generic-prin
               (make-instance method
                      'signature (list thread object)
                      'function generic_generic_prin\,Thread\,Object))

       (add-method generic-write
               (make-instance method
                      'signature (list thread object)
                      'function generic_generic_write\,Thread\,Object))
       ))
  ;; form ccc.c...
  (add-method equal
          (make-instance method
                 'signature (list object object)
                 'function generic_equal\,Object\,Object))
  (add-method equal
          (make-instance method
                 'signature (list pair pair)
                 'function generic_equal\,Cons\,Cons))
  (add-method equal
          (make-instance method
                 'signature (list vector vector)
                 'function generic_equal\,Vector\,Vector))

  (add-method equal
          (make-instance method
                 'signature (list structure structure)
                 'function generic_equal\,Basic_Structure\,Basic_Structure))
  (add-method equal
          (make-instance method
                 'signature (list class class)
                 'function generic_equal\,Standard_Class\,Standard_Class))

  (add-method copy
          (make-instance method
                 'signature (list object)
                 'function generic_copy\,Object))
  (add-method copy
          (make-instance method
                 'signature (list pair)
                 'function generic_copy\,Cons))
  (add-method copy
          (make-instance method
                 'signature (list vector)
                 'function generic_copy\,Vector))


  ;; and lastly...
  (add-method compute-discriminating-function
          (make-instance method
                 'signature (list generic-function)
                 'function compute-discriminating-function-as-method))

  ;; end module
  )